home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 26 / Cream of the Crop 26.iso / bbs / tdk_v136.zip / _EXIT.PAS next >
Pascal/Delphi Source File  |  1997-07-10  |  7KB  |  194 lines
  1. {
  2.  ▀▀▀▀▀▀▀▀  ▀▀▀▀▀▀    ▀▀   ▀▀
  3.    ▀▀     ▀▀   ▀▀   ▀▀  ▀▀
  4.   ▀▀     ▀▀   ▀▀▀  ▀▀▀▀▀  The DoorKit!
  5.  ▀▀     ▀▀   ▀▀   ▀▀  ▀▀
  6. ▀▀     ▀▀▀▀▀▀    ▀▀    ▀▀
  7. The BBS Door Development Kit By The People - For The People!
  8.  
  9.  
  10.    Feel free to modify or optimize this code at will. All I ask is that if
  11.    find a better way to do things (and you will), please send me a copy of
  12.    your modifications. Thanks in advance!....Larry L. Athey....}
  13.  
  14. UNIT _EXIT;
  15.  
  16. {   This unit will do the following:
  17.     --------------------------------
  18.  1. Installs a new exit procedure. If your program is halted by some sort of
  19.     internal error this will bypass the Pascal exit procedure and display a
  20.     better discription of the error as well as "Error Logging" the error.
  21.  
  22.  2. Saves and restores the HEAP marker automatically. This means that you
  23.     don't have to use dispose or freemem before your program exits, because
  24.     this will free the entire heap that was used, so you don't have to do a
  25.     thing!
  26.  
  27.  3. Installs a new memory handler. If you try to allocate a chunk of memory
  28.     to something and there's not enough heap, instead of halting with an
  29.     out of memory error like TP does, this will continue normally with the
  30.     program, but the variable that you tried to assign the memory to will
  31.     have the value NIL. This makes it easier to do error checks when
  32.     allocating memory.                                                         }
  33.  
  34. INTERFACE
  35.  
  36. USES DOS;
  37.  
  38. CONST
  39.   MAX_ExitProcs = 16; {Adjust as needed, up to 256 processes allowed.}
  40.  
  41. TYPE
  42.   TExitProc = PROCEDURE;
  43.   TProcAry  = ARRAY[1..Max_ExitProcs] OF tExitProc; {Ary=1024 bytes}
  44.  
  45. FUNCTION AddtoExitChain(Proc : tExitProc) : BOOLEAN;
  46. {^ This adds a procedure to the "Exit Chain". Any procedures in the Exit
  47.    Chain are called when your program ends, automatically...No matter how
  48.    the program gets terminated (Normally, Carrier Drop, HALT(), ^C).
  49.  
  50.    Proc = Procedure to add. The procedure cannot have any parameters,
  51.           and MUST be compiled FAR.
  52.  
  53.    The procedures are called in a "LIFO" (Last In First Out) fashion. This
  54.    is so the Comport routines will be the very last thing to DeInit itself.
  55.    For 2 reasons. 1] So you don't have to worry about Calling DeInitComport
  56.    at the end of your program. The DoorKit adds its own procedure to the
  57.    ExitChain to DeInit itself for you (it's always the very first procedure
  58.    in the chain)  2] Since The DoorKit itself is last to be shut down, any
  59.    of your procedures in the Exit Chain can use the comport still, if you
  60.    need / want to (so long as you don't call DeInitComport yourself!)....}
  61.  
  62. IMPLEMENTATION
  63.  
  64. TYPE
  65.   String10 = STRING[10];
  66.  
  67. CONST
  68.   ChainNum : INTEGER = 0;
  69.  
  70. VAR
  71.   ExitChain     : TProcAry;
  72.   SavedExitProc : POINTER;
  73.   Hp            : POINTER;
  74.  
  75. CONST
  76.   Hx : ARRAY[0..15] OF CHAR = '0123456789ABCDEF';
  77.  
  78. {───────────────────────────────────────────────────────────────────────────}
  79. FUNCTION AddtoExitChain;
  80. BEGIN
  81.   AddtoExitChain := FALSE;
  82.   IF (ChainNum < MAX_ExitProcs) AND (@Proc <> NIL) THEN BEGIN
  83.     INC(ChainNum);
  84.     ExitChain[ChainNum] := Proc;
  85.     AddtoExitChain      := TRUE;
  86.   END;
  87. END;
  88. {───────────────────────────────────────────────────────────────────────────}
  89. FUNCTION Hex2(B : BYTE) : String10;
  90. BEGIN
  91.   Hex2 := Hx[(B SHR 4) AND 15] + Hx[B AND 15];
  92. END;
  93. {───────────────────────────────────────────────────────────────────────────}
  94. FUNCTION Hex4(W : WORD) : String10;
  95. BEGIN
  96.   Hex4 := Hex2(HI(W)) + Hex2(LO(W));
  97. END;
  98. {───────────────────────────────────────────────────────────────────────────}
  99. FUNCTION CustomHeapError(Size : WORD) : INTEGER; Far;
  100. BEGIN
  101.   CustomHeapError := 1;
  102. END;
  103. {───────────────────────────────────────────────────────────────────────────}
  104. FUNCTION ErrorMessage(ECode : WORD) : STRING;
  105. BEGIN
  106.   CASE ECode OF
  107.       1 : ErrorMessage := 'Invalid function number.';
  108.       2 : ErrorMessage := 'File not found.';
  109.       3 : ErrorMessage := 'Path not found.';
  110.       4 : ErrorMessage := 'Too many open files.';
  111.       5 : ErrorMessage := 'File access denied.';
  112.       6 : ErrorMessage := 'Invalid file handle.';
  113.      12 : ErrorMessage := 'Invalid file access code.';
  114.      15 : ErrorMessage := 'Invalid drive number.';
  115.      16 : ErrorMessage := 'Cannot remove current directory.';
  116.      17 : ErrorMessage := 'Cannot rename across drives.';
  117.      18 : ErrorMessage := 'No more files.';
  118.     100 : ErrorMessage := 'Disk read error.';
  119.     101 : ErrorMessage := 'Disk write error.';
  120.     102 : ErrorMessage := 'File not assigned.';
  121.     103 : ErrorMessage := 'File not open.';
  122.     104 : ErrorMessage := 'File not open for input.';
  123.     105 : ErrorMessage := 'File not open for output.';
  124.     106 : ErrorMessage := 'Invalid numeric format.';
  125.     150 : ErrorMessage := 'Disk is write-protected.';
  126.     151 : ErrorMessage := 'Bad drive request struct length.';
  127.     152 : ErrorMessage := 'Drive not ready.';
  128.     154 : ErrorMessage := 'CRC error in data.';
  129.     156 : ErrorMessage := 'Disk seek error.';
  130.     157 : ErrorMessage := 'Unknown media type.';
  131.     158 : ErrorMessage := 'Sector Not Found.';
  132.     159 : ErrorMessage := 'Printer out of paper.';
  133.     160 : ErrorMessage := 'Device write fault.';
  134.     161 : ErrorMessage := 'Device read fault.';
  135.     162 : ErrorMessage := 'Hardware failure.';
  136.     200 : ErrorMessage := 'Division by zero.';
  137.     201 : ErrorMessage := 'Range check error.';
  138.     202 : ErrorMessage := 'Stack overflow error.';
  139.     203 : ErrorMessage := 'Heap overflow error.';
  140.     204 : ErrorMessage := 'Invalid pointer operation.';
  141.     205 : ErrorMessage := 'Floating point overflow.';
  142.     206 : ErrorMessage := 'Floating point underflow.';
  143.     207 : ErrorMessage := 'Invalid floating point operation.';
  144.     208 : ErrorMessage := 'Overlay manager not installed.';
  145.     209 : ErrorMessage := 'Overlay file read error.';
  146.     210 : ErrorMessage := 'Object not initialized.';
  147.     211 : ErrorMessage := 'Call to abstract method.';
  148.     212 : ErrorMessage := 'Stream registration error.';
  149.     213 : ErrorMessage := 'Collection index out of range.';
  150.     214 : ErrorMessage := 'Collection overflow error.';
  151.     215 : ErrorMessage := 'Arithmetic overflow error.';
  152.     216 : ErrorMessage := 'General Protection fault.';
  153.   END;
  154. END;
  155. {───────────────────────────────────────────────────────────────────────────}
  156. PROCEDURE CustomExit; Far;
  157. VAR
  158.   I       : INTEGER;
  159.   Txt     : TEXT;
  160.   Msg     : STRING;
  161.   DirInfo : SearchRec;
  162. BEGIN
  163.   IF ErrorAddr <> NIL THEN BEGIN
  164.     Msg := ErrorMessage(ExitCode);
  165.     Asm mov ax,3; INT 10h END;
  166.     ASSIGN(Txt,'ERROR.LOG');
  167.     FINDFIRST('ERROR.LOG',Archive,DirInfo);
  168.     IF DOSERROR <> 0 THEN BEGIN
  169.       REWRITE(Txt);
  170.       CLOSE(Txt);
  171.     END;
  172.     APPEND(Txt);
  173.     WRITELN(Txt,'■ A RunTime Error Has Occured - Program Halted!');
  174.     WRITELN(Txt,'  Address  = ',Hex4(SEG(ErrorAddr^)),':',Hex4(OFS(ErrorAddr^)));
  175.     WRITELN(Txt,'  ExitCode = ',ExitCode);
  176.     WRITELN(Txt,'  Error    = ',Msg);
  177.     WRITELN(Txt);
  178.     CLOSE(Txt);
  179.     RESET(Input);
  180.     ErrorAddr := NIL;
  181.     ExitCode  := 0;
  182.   END;
  183.   FOR I := ChainNum DOWNTO 1 DO IF @ExitChain[I] <> NIL THEN ExitChain[I];
  184.   RELEASE(Hp);
  185.   ExitProc := SavedExitProc;
  186. END;
  187. {───────────────────────────────────────────────────────────────────────────}
  188. BEGIN
  189.   SavedExitProc := ExitProc;
  190.   ExitProc      := @CustomExit;
  191.   HeapError     := @CustomHeapError;
  192.   MARK(Hp);
  193. END.
  194.